CD Ware Multimedia 1995 May/cd Ware (Juegos) Epimundo.iso/WIN/VB_TOOLS/FRMT_VB.ZIP/FORMATVB.FRM

Visual Basic Form | 1992-12-09 | 31.4 KB | 800 lines

VERSION 2.00
Begin Form FormFormatVB
   Caption         =   "Format VB Program"
   Height          =   4360
   Icon            =   FORMATVB.FRX:0000
   Left            =   1485
   LinkMode        =   1  'Source
   LinkTopic       =   "Form1"
   ScaleHeight     =   3480
   ScaleWidth      =   6705
   Top             =   1520
   Width           =   6855
   Begin CommandButton CommandClear
      Caption         =   "&Clear"
      Height          =   620
      Left            =   4560
      TabIndex        =   5
      Top             =   360
      Width           =   855
   End
   Begin CommonDialog CMDialogFile
      Left            =   240
      Top             =   2640
   End
   Begin TextBox TextBox
      Height          =   735
      Index           =   1
      Left            =   1800
      MultiLine       =   -1  'True
      TabIndex        =   1
      Text            =   "Text1"
      Top             =   1200
      Width           =   4575
   End
   Begin CommandButton CommandQuit
      Caption         =   "&Quit"
      Height          =   620
      Left            =   5520
      TabIndex        =   3
      Top             =   360
      Width           =   855
   End
   Begin CommandButton CommandProcess
      Caption         =   "&Process a Visual Basic File"
      Height          =   620
      Left            =   1800
      TabIndex        =   0
      Top             =   360
      Width           =   2655
   End
   Begin PictureBox PictureIcon
      AutoRedraw      =   -1  'True
      AutoSize        =   -1  'True
      BorderStyle     =   0  'None
      Height          =   640
      Left            =   240
      Picture         =   FORMATVB.FRX:0302
      ScaleHeight     =   640
      ScaleWidth      =   480
      TabIndex        =   4
      Top             =   240
      Width           =   480
   End
   Begin Label LabelBox
      Alignment       =   1  'Right Justify
      AutoSize        =   -1  'True
      Caption         =   "LabelBox"
      Height          =   195
      Index           =   1
      Left            =   840
      TabIndex        =   2
      Top             =   1200
      Width           =   795
   End
   Begin Menu MenuOptions
      Caption         =   "&Options"
      Begin Menu MenuDefaultPath
         Caption         =   "&Set Default Path"
      End
   End
   Begin Menu MenuQuit
      Caption         =   "&Quit"
   End
   Begin Menu MenuHelp
      Caption         =   "&Help"
      Begin Menu MenuHelpIndex
         Caption         =   "&Index"
         Shortcut        =   {F1}
      End
      Begin Menu MenuHelpSep
         Caption         =   "-"
      End
      Begin Menu MenuHelpAbout
         Caption         =   "&About"
      End
   End
' FormatVB.Frm - Format VB .txt file
' 92/10/03 Copyright 1992, Larry Rebich, The Bridge, Inc.
' 92/10/04 Add Table of Contents
' 92/10/13 Use *.txt files
' 92/10/16 Fix problems with Left Margin and Tabs Expansion
' 92/12/01 Convert to VB 2.0, use .Frm files
' 92/12/07 Add Captions to Table of Contents
' 92/12/09 Add Help
' 92/12/09 Send a copy to Inside Visual Basic, Cobb Group
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''
DefInt A-Z                      'default data type is integer
Const Version = "1.0"                   'version
Const VersionDate = "December, 1992"    'version date, 92/12/09
Declare Function WritePrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpString As String, ByVal lplFileName As String) As Integer
Declare Function GetPrivateProfileString Lib "Kernel" (ByVal lpApplicationName As String, ByVal lpKeyName As String, ByVal lpDefault As String, ByVal lpReturnedString As String, ByVal nSize As Integer, ByVal lpFileName As String) As Integer
Const Pgm$ = "FormatVB Options" 'used in formatvb.ini file
Const Which$ = "Default Path"   'used in formatvb.ini as well
Const FileIni$ = "FormatVB.Ini" 'save default path name here, Windows Directory
Const FormatVBHelpFile = "FormatVB.Hlp" 'help file name
Const TempFName$ = "~ormatVB"   'temporary file name
Const MaxSubs = 1500    'maximum number of sub, functions - increase if necessary
Dim Recs$(1 To MaxSubs)         'store subs, functions here
Dim RecCount As Integer         'number of records read
Dim LFlag(1 To MaxSubs)         'flag, 0=normal text line
'                                      1=Sub, Control_ [contains underline]
'                                      3=Sub, Standard
'                                      5=End Sub
'                                      7=Function
'                                      8=End Function
Const xSub$ = "SUB"             'type 1 or 3
Const xFun$ = "FUNCTION"        'type 7
Const xEnd$ = "END"             'type 5 or 8
Dim SortRec$(1 To MaxSubs)      'put sub/function records here
Dim SortCt(1 To MaxSubs)        'and its record number
Dim SortInSubCount(1 To MaxSubs)'and sub/function contains this many
Dim SortLFlag(1 To MaxSubs)     'lflag here, type of sub/function
Dim SortThisMany As Integer     'how many subs and functions
Dim FirstSub As Integer         'first line containing sub or function
Dim InFile As String            'input file name
Dim OutFile As String           'output file
Dim RandomFile As String        'store them here randomly
Dim RandomRecSize As Integer    'random file record size
Dim LongestLen As Integer       'Longest line length
Dim LongestRec As Integer       'longest record number
Dim GotInFile As Integer        'we have a file switch
Dim PathName As String          'use this path name
Dim InCmDialog As Integer       'in here now switch
Dim VBFrmFile As Integer        'is it a VB 2.0 .frm file
Dim SepLine As String           'separator line
Dim AuthorIsUser As Integer     'is it the author
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub CommandClear_Click ()
    For i = 1 To 3              'clear the text boxes
    TextBox(i).Text = ""
    Next
End Sub
Sub CommandProcess_Click ()
    Screen.MousePointer = HourGlass     'tell 'em to wait
    CommandProcess.Enabled = False      'dim this control
    CommandQuit.Enabled = False         'dim this one as well
    CommandClear.Enabled = False
    MenuOptions.Enabled = False         'dim this menu items
    MenuQuit.Enabled = False
    MenuHelp.Enabled = False
    PictureIcon.SetFocus                'so no focus on text box
    CommandClear_Click                  'clear the text boxes
    GetInFileName                       'get the file to process
    If GotInFile = False Then GoTo ExitThis 'open failed, cancel pressed
    Screen.MousePointer = HourGlass     'back on in case set off in Dialog
    GetOutFileName                      'get output file name from input
    GetRandomRecSize                    'get largest line size
    GetFileRecords                      'read the input file
    WriteJustSubAndFunRecords           'write a temporary file
    SortEm                              'sort the subroutine and function names
    PutFileRecords                      'build the output file
    Beep                                'tell 'em we are done
    Screen.MousePointer = Default       'back to normal
    DeleteTemps                         'delete temporary files
ExitThis:                               'if cancel pressed
    CommandProcess.Enabled = True       'back on
    CommandQuit.Enabled = True          'back on
    CommandClear.Enabled = True
    MenuOptions.Enabled = True
    MenuQuit.Enabled = True
    MenuHelp.Enabled = True
    CommandProcess.SetFocus             'and light it
    Screen.MousePointer = Default       'done waiting
End Sub
Sub CommandQuit_Click ()
    FormatVBHelp Help_Quit, 0&  'dump help file if active
    End                         'quit
End Sub
Sub DeleteTemps ()
    Dim Temp As String
    Temp = TempFName + ".*"     'temp file names to delete
'    If AuthorIsUser Then        'for testing, delete the temps?
'        Msg$ = "Delete temporary files? "
'        MsgRtn% = MsgBox(Msg$, MB_YesNo + MB_IconQuestion, "Kill " + Temp)
'        If MsgRtn% = IDNo Then Exit Sub     'said no, so don't delete
'    End If
    Kill PathName + Temp        'delete all temp files
End Sub
Sub DoTextBox3 (RecCountPut As Integer, TheRec As String, Force As Integer)
    Dim RecNum As String
    If RecCountPut Mod 9 = 0 Or Force Then      'only every 9 or forced
    RecNum = Format$(RecCountPut, "####")   'record number
    TextBox(3).Text = RecNum + " " + TheRec 'now into text box
    End If
End Sub
Sub DumpSpecialCharacters (Rec As String)
'was needed for printer output, not needed for VB 2.0 Text Output
    If VBFrmFile Then Exit Sub  'little faster
    Dim Lf As String * 1        'line feed
    Dim Cr As String * 1        'carriage return
    Dim Ff As String * 1        'form feed
    Dim x As String
    Dim y As Integer
    Lf = Chr$(10)
    Cr = Chr$(13)
    Ff = Chr$(12)
    x = " " + Rec               'into x and add a blank
    While InStr(x, Lf)          'dump line feeds
    y = InStr(x, Lf)
    x = Mid$(x, 1, y - 1) + Mid$(x, y + 1)
    Wend
    While InStr(x, Cr)          'dump carriage returns
    y = InStr(x, Cr)
    x = Mid$(x, 1, y - 1) + Mid$(x, y + 1)
    Wend
    While InStr(x, Ff)          'dump form feeds
    y = InStr(x, Ff)
    x = Mid$(x, 1, y - 1) + Mid$(x, y + 1)
    Wend
    Rec = Mid$(x, 2)            'dump blank that was added
End Sub
Sub ExpandTabs (Rec As String)
    Static Lm As Integer                'previous left margin
    Dim SkipLmSet As Integer            'skip resetting setting left margin
    Dim t As String * 1                 'tab
    Dim s As String                     'spacer
    Dim x As String                     'work string
    Dim ExtraChars As String            'based upon left margin
    ExtraChars = ""                     'clear for now
    t = Chr$(9)                         'tab character
    SkipLmSet = False                   'switch, off if any tab
    If Lm > 1 Then                      'if margin greater than this
    If InStr(Rec, t) > 0 Then       'and if there is a tab
        ExtraChars = String$(Lm - 1, " ")   'add some more characters
        SkipLmSet = True            'and skip setting left margin
    End If
    End If
    If InStr(Rec, t) > 0 Then           'any tab
    Rec = ExtraChars + Rec          'add the extra characters to the record
    End If
    x = " " + Rec                       'one blank
    CountTabs = 0                       'count tabs
    While InStr(x, t) > 0               'expand the tabs
    CountTabs = CountTabs + 1       'double second tab
    If CountTabs = 1 Then
        s = String$(4, " ")
    Else
        s = String$(8, " ")
    End If
    i = InStr(x, t)
    x = Mid$(x, 1, i - 1) + s + Mid$(x, i + 1)
    Wend
    Rec = Mid$(x, 2)                    'dump extra blank
    If CountTabs > 4 Then               'should not get here!!
    Msg$ = "Found " + Format$(CountTabs, "##0") + " tabs in line:" + Str$(RecCount)
    Msg$ = Msg$ + "  Record: |" + Rec + "|.  The line may not expand correctly."
    MsgBox Msg$, MB_IconExclamation, "Too Many Tabs?"
    End If
    If SkipLmSet = False Then
    x = Mid$(x, 2)                  'and work variable
    x = RTrim$(x)                   'get number of leading blanks
    sl = Len(x)                     'length before dumping leading blanks
    x = LTrim$(x)                   'dump leading blanks
    el = Len(x)                     'length without leading blanks
    Lm = sl - el + 1                'left margin
    End If
End Sub
Sub Form_Load ()
    CenterForm Me, 0, 0                 'center on screen
    GetPathFromIni                      'get default path from ini
    SetColors                           'some color is nice
    LoadBoxes                           'set control locations
    SepLine = "'" + String$(78, "-") + "'"  'separates subs and functions
    RandomFile = TempFName + ".rnd"     'temp random file name
    x$ = Environ$("AUTHOR")             'is author the user
    If UCase$(x$) = UCase$("LarryRebich") Then
    AuthorIsUser = True             'environ has author's name
    End If
    Show                                'show 'em
    Refresh                             'force display before asking for file
    CommandProcess_Click                'start 'em off with file dialog
End Sub
Sub FormatVBHelp (WCmd%, dwData As Long)
    Screen.MousePointer = HourGlass     'show 'em we are working
    x% = WinHelp(hWnd, App.Path + FormatVBHelpFile, WCmd%, ByVal dwData)
    Screen.MousePointer = Default       'done loading
End Sub
Sub GetFileRecords ()               'read the records
    ReDim a$(1 To 200)              'array for parse
    Dim Rec As String               'read ascii file into here
    Dim Blanks As String            'bunch of blanks
    Blanks = String$(RandomRecSize, " ")    'fill random file with recs and blanks
    Erase LFlag                     'zeros into this array
    RecCount = 0                    'record counter
    f = FreeFile                    'file id
    Open PathName + InFile For Input As #f
    f2 = FreeFile                   'next file id
    Open PathName + RandomFile For Output As #f2 'work with a new one
    Close #f2
    Kill PathName + RandomFile      'dump the one just opened
    Open PathName + RandomFile For Random As #f2 Len = RandomRecSize + 2
    FirstSub = 0                    'this will contain the rec number of the first sub
    While Not EOF(f)                'read until end of file
    Line Input #f, Rec              'read the record
    DumpSpecialCharacters Rec       'get rid of special characters
    x$ = Trim$(Rec)                 'don't process completely blank records
    If x$ <> "" Then
        RecCount = RecCount + 1     'bump record counter
        ExpandTabs Rec
        Rec = Left$(Rec + Blanks, RandomRecSize)    'add blanks to pad record
        Put #f2, RecCount, Rec          'store in random file
        x$ = UCase$(LTrim$(Rec))        'work with it to see if Sub, End, etc.
        If Left$(x$, 1) <> "'" Then     'if starts with comment then skip
        anum = Parse(x$, a$(), " ") 'split apart
        Select Case a$(1)           'first
            Case xSub$              'sub
            GoSub IfFirstSubFun 'is it the first one
            If InStr(a$(2), "_") > 0 Then
                LFlag(RecCount) = 1     'command_event
            Else
                LFlag(RecCount) = 3     'standard sub
            End If
            Recs(RecCount) = Rec        'store subs into matrix
            TextBox(2).Text = " " + Rec
            Case xFun$              'function
            GoSub IfFirstSubFun
            LFlag(RecCount) = 7
            Recs(RecCount) = Rec
            TextBox(2).Text = " " + Rec
            Case xEnd$
            Select Case a$(2)
                Case xSub$      'end sub
                LFlag(RecCount) = 5
                Case xFun$      'end function
                LFlag(RecCount) = 8
            End Select
            Case Else               'nothing special
            LFlag(RecCount) = 0
            DoTextBox3 RecCount, LTrim$(Rec), False
            Refresh
        End Select
        Else
        DoTextBox3 RecCount, LTrim$(Rec), False
        End If
    End If
    Wend
    DoTextBox3 RecCount, LTrim$(Rec), True    'in case not shown
    Close #f, #f2       'done with input and done creating random file
    Reset
    'in case there were no subs or functions [constant.txt!]
    If FirstSub = 0 Then FirstSub = RecCount + 1
    Exit Sub
IfFirstSubFun:
    If FirstSub = 0 Then FirstSub = RecCount    'first sub record number
    Return
End Sub
Sub GetInFileName ()
    Dim Fltr As String, f As Integer, Rec1 As String
    InCmDialog = True                   'get file to process
    CmDialogFile.DefaultExt = ".frm"    'default extension
    CmDialogFile.DialogTitle = "VB Input File"
    CmDialogFile.Filename = "*.frm"
    Fltr = ""
    Fltr = Fltr & "VB Forms [*.frm]|*.frm|"     'for VB 2.0 92/12/01
    Fltr = Fltr & "Bas Files [*.bas]|*.bas|"
    Fltr = Fltr & "Sub Files [*.sub]|*.sub|"
    Fltr = Fltr & "Glb Files [*.glb]|*.glb|"
    Fltr = Fltr & "Txt Files [*.txt]|*.txt|"
    Fltr = Fltr & "Prn Files [*.prn]|*.prn|"
    Fltr = Fltr & "All Files [*.*]|*.*|"
    CmDialogFile.Filter = Fltr
    CmDialogFile.Flags = OFN_READONLY Or OFN_HIDEREADONLY Or OFN_PATHMUSTEXIST
    CmDialogFile.CancelError = True     'allow cancel key to cause error
    CmDialogFile.InitDir = PathName
    GotInFile = True                    'say we got one
    On Error Resume Next                'in case cancel pressed
    CmDialogFile.Action = DLG_FILE_OPEN 'do it
    If Err = 0 Then                     'ok, got name
    InFile = CmDialogFile.Filetitle
    PathName = CmDialogFile.Filename
    PathName = Mid$(PathName, 1, InStr(PathName, InFile) - 1)
    If Right$(PathName, 1) <> "\" Then
        PathName = PathName + "\"
    End If
    If InStr(LCase$(InFile), ".frm") > 0 Then 'VB 2.0
        f = FreeFile                'check to see if it is valid
        Open PathName & InFile For Input As #f
        Line Input #f, Rec1
        Rec1 = Trim$(Rec1)
        If Rec1 <> "VERSION 2.00" Then
        GotInFile = False
        Beep
        TextBox(1).Text = "  " + LCase$(PathName + InFile) + " - Not a VB 2.0 File"
        Else
        GoSub PathAndIniUpdate
        VBFrmFile = True        'it is a VB .frm file
        End If
    Else                            'not VB 2.0
        GoSub PathAndIniUpdate
        VBFrmFile = False           'not VB .frm file
    End If
    ElseIf Err = 32755 Then             'cancel pressed
    GotInFile = False
    End If
    InCmDialog = False                  'done with this process
    Exit Sub
PathAndIniUpdate:                       'ok, store it
    UpdateIni PathName                  'store it
    TextBox(1).Text = "  " + LCase$(PathName + InFile) + " - Input"
    Return
End Sub
Sub GetOutFileName ()                   'get OutFile from InFile
    Dim x As String
    If InStr(InFile, ".") > 0 Then      'find period
    x = Mid$(InFile, 1, InStr(InFile, ".") - 1)
    OutFile = x + ".wrk"
    Else
    OutFile = "FormatVB.Wrk"        'should not get here
    End If
End Sub
Sub GetPathFromIni ()
    Dim Buf As Integer, Value As String, Num As Integer
    Buf = 64                            'read the .ini file
    Value = Space$(Buf)
    Num = GetPrivateProfileString(Pgm$, Which, "", Value, Buf, FileIni)
    If Num > 0 Then
    PathName = Trim$(Mid$(Value, 1, Num))
    Else
    PathName = ""                   'no .ini value found
    End If
    TextBox(1).Text = "  " + PathName   'display it
End Sub
Sub GetRandomRecSize ()
'get the longest line, needed to set the random record length
    Dim x As String
    Dim z As Integer
    f = FreeFile                            'get the largest line number
    Open PathName + InFile For Input As #f
    While Not EOF(f)
    Line Input #f, x                    'read line
    DumpSpecialCharacters x             'drop special characters
    ExpandTabs x                        'expand it
    x = RTrim$(x)                       'dump any trailing blanks
    z = Len(x)                          'size of remaining record
    If RandomRecSize < z Then           'if x longer then use save it
        RandomRecSize = z               'use it
    End If
    Wend
    Close #f                                'done, close it
End Sub
Sub LoadBoxes ()
    Static HereBefore As Integer        'set up the screen
    Of = 100
    If HereBefore = False Then          'do this just once
    HereBefore = True
    For i = 2 To 3
        Load LabelBox(i)            'load the extra labels and boxes
        LabelBox(i).Visible = True
        Load TextBox(i)
        TextBox(i).Visible = True
    Next
    For i = 1 To 3
        If i < 3 Then
        TextBox(i).Height = CommandProcess.Height * .75
        Else
        TextBox(i).Height = CommandProcess.Height * 1.5
        TBLeft = TextBox(i).Width * .35
        TextBox(i).Width = TextBox(1).Width + TBLeft
        End If
    Next
    End If
    TextBox(1).Top = CommandProcess.Top + CommandProcess.Height + Of * 2
    TextBox(1).Left = CommandProcess.Left
    TextBox(2).Left = TextBox(1).Left
    TextBox(3).Left = TextBox(1).Left - TBLeft
    TextBox(2).Top = TextBox(1).Top + TextBox(1).Height + Of
    TextBox(3).Top = TextBox(2).Top + TextBox(1).Height + Of
    LabelBox(1).Caption = "File"
    LabelBox(2).Caption = "Routine"
    LabelBox(3).Caption = "Line"
    For i = 1 To 3
    If i > 1 Then
        TextBox(i).Text = ""
    End If
    LabelBox(i).Top = TextBox(i).Top + Of
    LabelBox(i).Left = TextBox(i).Left - LabelBox(i).Width - Of * 2
    If i = 3 Then
        LabelBox(i).Left = LabelBox(i).Left - TBLeft
    End If
    LabelBox(i).BackColor = BackColor
    LabelBox(i).ForeColor = ForeColor
    Next
End Sub
Sub MenuDefaultPath_Click ()
'allow a default path name to be entered
    P$ = "Enter a default path name, or press enter to retain the current path."
    t$ = "Default Path"
TryAgain:
    Value$ = InputBox$(P$, t$, PathName)
    If Value$ = PathName Then Exit Sub  'no change
    If Value$ = "" Then Exit Sub        'cancel pressed
    If Right$(Value$, 1) <> "\" Then    'add ending \ if needed
    Value$ = Value$ + "\"
    End If
    On Error GoTo BadDir                'if no file or bad name
    x$ = Dir$(Value$ + "*.*")           'get any file
    If x$ = "" Then                     'any file in directory?
    Msg$ = "No files in directory: " + Value$
    MsgBox Msg$, MB_IconExclamation, "Invalid Directory"
    GoTo TryAgain
    End If
    PathName = Value$                   'store the new value
    TextBox(1).Text = "  " + PathName   'into text box to display it
    UpdateIni Value$                    'update the .ini file
    Exit Sub
BadDir:
    MsgBox Error$, MB_IconExclamation, "Failed to Find Any Files"
    Resume TryAgain
End Sub
Sub MenuHelpAbout_Click ()
    Dim Msg As String, Nl As String * 2     'some info about the author
    Dim Sp As String                        'some spaces
    Sp = String$(9, " ")
    Nl = Chr$(13) + Chr$(10)
    Msg = "FormatVB - Format Visual Basic Text" + Nl
    Msg = Msg + "Version: " + Version + " " + VersionDate + Nl + Nl
    Msg = Msg + Sp + "Copyright " + Format$(Now, "yyyy") + Nl + Nl
    Msg = Msg + Sp + "Larry Rebich" + Nl
    Msg = Msg + Sp + "The Bridge, Inc." + Nl
    Msg = Msg + Sp + "199 California Drive" + Nl
    Msg = Msg + Sp + "Millbrae, CA  94030" + Nl + Nl
    Msg = Msg + Sp + "415-697-2730" + Nl
    Msg = Msg + Sp + "Fax: [phone]"
    MsgBox Msg, MB_IconQuestion, "About FormatVB"
End Sub
Sub MenuHelpIndex_Click ()
    FormatVBHelp Help_Context, 10&  'help requested
End Sub
Sub MenuQuit_Click ()
    CommandQuit_Click               'end it
End Sub
Sub PrintSepLine (f As Integer)
    PrintSub f, SepLine, 0      'print a separator line
End Sub
Sub PrintSub (f As Integer, PLine As String, LineNumber As Integer)
' common print subroutine
    Static HoldLine As String
    If HoldLine = SepLine And PLine = SepLine Then  'no two sep together
    Exit Sub
    End If
    HoldLine = PLine
    Dim Counter As String
    If LineNumber > 0 Then              'print line number, unless zero
    Counter = Right$("    " + Format$(LineNumber, "####"), 4)
    Print #f, Counter; " "; PLine
    If Len(PLine) > LongestLen Then
        LongestRec = LineNumber     'new value
        LongestLen = Len(PLine)     'and save for compare
    End If
    Else
    Print #f, PLine     'don't count this line, usually a separator
    End If
End Sub
Sub PutFileRecords ()
' write them to the .wrk file now, almost done
    Dim HaveBeginSw As Integer, HaveEndSw As Integer
    LongestRec = 0                      'reset this
    LongestLen = 0                      'and this
    RecCountPut = 0                     'record counter
    CommentStringLen = 40
    CommentString$ = String$(CommentStringLen, "'")
    TextBox(1).Text = " " + LCase$(PathName + OutFile) + " - Output"
    f = FreeFile
    Open PathName + OutFile For Output As #f
    f2 = FreeFile                       'random file
    Open PathName + RandomFile For Random As #f2 Len = RandomRecSize + 2
    If SortThisMany >= 1 Then
    PutTableOfContents f, f2        'do the table of contents
    PrintSepLine f
    End If
    If FirstSub > 1 Then                'any general
    For j = 1 To FirstSub - 1       'general info
        GoSub WriteRec
        DoTextBox3 RecCountPut, x$, False
    Next
    PrintSepLine f
    End If
    For i = 1 To SortThisMany           'do Command_Click type first
    If SortLFlag(i) = 1 Then
        For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1
        GoSub WriteRec
        GoSub IntoTextBox
        Next
        PrintSepLine f
    End If
    Next
    For i = 1 To SortThisMany           'do normal subs next
    If SortLFlag(i) = 3 Then
        For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1
        GoSub WriteRec
        GoSub IntoTextBox
        Next
        PrintSepLine f
    End If
    Next
    For i = 1 To SortThisMany           'do functions next
    If SortLFlag(i) = 7 Then
        For j = SortCt(i) To SortCt(i) + SortInSubCount(i) - 1
        GoSub WriteRec
        GoSub IntoTextBox
        Next
        PrintSepLine f
    End If
    Next
    'wrap up
    x$ = String$(4, " ")
    m$ = "####"
    PrintSub f, Right$(x$ + Format$(RecCountPut, m$), 4) + " lines in file " + LCase$(PathName + OutFile), 0
    PrintSub f, Right$(x$ + Format$(LongestLen, m$), 4) + " characters in longest line", 0
    PrintSub f, Right$(x$ + Format$(LongestRec, m$), 4) + " first longest line", 0
    Close                           'close any open files
    Reset                           'force buffers to disk
    Exit Sub
WriteRec:                           'write the temp file
    RecCountPut = RecCountPut + 1
    Get #f2, j, x$
    x$ = RTrim$(x$)
    y$ = LTrim$(x$)                 'dump long strings with only '''''
    If Left$(y$, CommentStringLen) <> CommentString$ Then
    PrintSub f, x$, RecCountPut
    If VBFrmFile Then               'is this a VB 2.0 form
        If HaveEndSw = False Then   'only do this once
        If HaveBeginSw = False Then
            If Left$(LCase$(x$), 5) = "begin" Then
            HaveBeginSw = True
            End If
        Else
            If Left$(LCase$(x$), 3) = "end" Then
            HaveEndSw = True
            PrintSepLine f  'separator after last end
            End If
        End If
        End If
    End If
    End If
    Return
IntoTextBox:                        'show record in text box
    If j = SortCt(i) Then           'sub or function name
    TextBox(2).Text = " " + x$
    Else                            'just an ordinary record
    DoTextBox3 RecCountPut, LTrim$(x$), True
    End If
    Return
End Sub
Sub PutTableOfContents (f As Integer, f2 As Integer)
'write the table of contents to the .wrk file
    Dim Toc As String                   'sub into here
    Dim LToc As String                  'local
    Dim HoldFlag As Integer             'extra line on type break
    ReDim SecType(1 To 7) As String     'section names stored here
    Dim SecLen As Integer               'store section len here
    SecType(1) = "     Controls    "    'section headings
    SecType(3) = "     Subroutines "
    SecType(7) = "     Functions   "
    SecLen = Len(SecType(1))            'longest one
    f9 = FreeFile                       'work file
    TocOffset = SecLen                  'TOC offset
    ReDim AToc(1 To 500) As String
    Open PathName + TempFName + ".toc" For Output As #f9
    StartLine = FirstSub                'first subroutine line number
    For i = 1 To SortThisMany           'this many to put in Toc
    Get #f2, SortCt(i), Toc         'get the sub
    Toc = LTrim$(RTrim$(Toc))
    aTocNum = Parse(Toc, AToc(), " ")'just sub and name
    LToc = Left$(AToc(1) + " " + AToc(2) + String$(40, "."), 40)
    LToc = String$(TocOffset, " ") + LToc + Right$("....." + Format$(StartLine, "####"), 4)
    LToc = SecType(SortLFlag(i)) + Mid$(LToc, TocOffset)    'add caption
    SecType(SortLFlag(i)) = String$(SecLen, " ")'kill it after first one
    If i > 1 Then                   'not first time
        If HoldFlag <> SortLFlag(i) Then    'extra line on Flag break
        HoldFlag = SortLFlag(i)
        Print #f9, ""           'blank line between types
        Print #f, ""
        End If
    Else
        HoldFlag = SortLFlag(i)     'first time, set hold flag
    End If
    Print #f9, LToc                 'work file
    Print #f, LToc                  'real file
    StartLine = StartLine + SortInSubCount(i)
    Next
    Print #f, ""                        'extra line after TOC
    Close #f9                           'close temp file
End Sub
Sub SetColors ()
    BackColor = Application_Workspace   'some color is nice
    ForeColor = Window_Text
End Sub
Sub SortEm ()
    Erase SortInSubCount            'clear the arrays
    Erase SortRec
    Erase SortCt
    SortThisMany = 0
    For i = 1 To RecCount
    Select Case LFlag(i)        'build sort array
        Case 1, 3, 7            'sub or function
        SortThisMany = SortThisMany + 1
        ReDim RecArray$(1 To 500)
        x$ = Recs(i)            'into unindexed string
        RecArrayNumber = Parse(x$, RecArray$(), " ")
        x$ = RecArray$(1) + " " + RecArray$(2)
        SortRec(SortThisMany) = x$  'the sub, function
        SortCt(SortThisMany) = i    'record number
        SortLFlag(SortThisMany) = LFlag(i)
        SortInSubCount(SortThisMany) = SortInSubCount(SortThisMany) + 1
        Case Else               'all other types
        If SortThisMany > 0 Then    'count records in sub or function
            SortInSubCount(SortThisMany) = SortInSubCount(SortThisMany) + 1
        End If
    End Select
    Next
    WriteEm PathName + TempFName + ".nrt"   'write unsorted temp file for debug
    For i = 1 To SortThisMany - 1   'sort decending by name, end up ascending
    For j = i + 1 To SortThisMany
        If SortRec(i) < SortRec(j) Then     'swap them
        SortSwap i, j
        End If
    Next
    Next
    WriteEm PathName + TempFName + ".srt"   'write sort by name for debug
    For i = 1 To SortThisMany - 1   'sort by type, end up ascending
    For j = i + 1 To SortThisMany
        If SortLFlag(i) >= SortLFlag(j) Then 'swap them
        SortSwap i, j
        End If
    Next
    Next
    WriteEm PathName + TempFName + ".typ"   'write final sort for debug
End Sub
Sub SortSwap (i As Integer, j As Integer)
    Dim Tmp As String, TmpCt As Integer
    Tmp = SortRec(i)                'swap sort array elements
    SortRec(i) = SortRec(j)
    SortRec(j) = Tmp
    TmpCt = SortCt(i)
    SortCt(i) = SortCt(j)
    SortCt(j) = TmpCt
    TmpCt = SortInSubCount(i)
    SortInSubCount(i) = SortInSubCount(j)
    SortInSubCount(j) = TmpCt
    TmpCt = SortLFlag(i)
    SortLFlag(i) = SortLFlag(j)
    SortLFlag(j) = TmpCt
End Sub
Sub TextBox_GotFocus (Index As Integer)
    If InCmDialog = True Then Exit Sub  'can't set focus while showing another screen
    CommandProcess.SetFocus             'don't allow focus on the text boxes
End Sub
Sub UpdateIni (Value As String)
    Dim Result As Integer           'update the .ini file
    Result = WritePrivateProfileString(Pgm$, Which$, LCase$(Value$), FileIni$)
    If Result = 0 Then              'should not get an error
    Msg$ = "Could not update " + UCase$(Which$) + "=" + UCase$(Value$) + " in File: " + UCase$(FileIni$)
    MsgBox Msg$, MB_IconExclamation, "Update INI Error"
    End If
End Sub
Sub WriteEm (WFile As String)
    Dim x1 As String, x2 As String, x3 As String
    f = FreeFile                'write temporary files, for debug
    Open WFile For Output As #f
    For i = 1 To SortThisMany
    x1 = Right$("    " + Trim$(Str$(SortCt(i))), 4)  'starting number
    x2 = Right$("    " + Trim$(Str$(SortInSubCount(i))), 4)  'records in sub
    x3 = Right$(" " + Trim$(Str$(SortLFlag(i))), 1)   'type
    Print #f, x1; " "; x2; " "; x3; " "; SortRec(i)
    Next
    Close #f
End Sub
Sub WriteJustSubAndFunRecords ()
    f = FreeFile                        'temporary file
    Open PathName + TempFName + ".lst" For Output As #f
    For i = 1 To RecCount
    If Len(Recs(i)) > 0 Then
        Print #f, FirstSub; " "; LFlag(i); " "; Recs(i)
    End If
    Next
    Close #f
    Reset
End Sub